home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclCmdMZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-12  |  34.9 KB  |  1,426 lines
  1. #ifdef macintosh
  2. #    pragma segment tclCmdMZ
  3. #endif
  4.  
  5. /* 
  6.  * tclCmdMZ.c --
  7.  *
  8.  *    This file contains the top-level command routines for most of
  9.  *    the Tcl built-in commands whose names begin with the letters
  10.  *    M to Z.  It contains only commands in the generic core (i.e.
  11.  *    those that don't depend much upon UNIX facilities).
  12.  *
  13.  * Copyright 1987-1991 Regents of the University of California
  14.  * Permission to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose and without
  16.  * fee is hereby granted, provided that the above copyright
  17.  * notice appear in all copies.  The University of California
  18.  * makes no representations about the suitability of this
  19.  * software for any purpose.  It is provided "as is" without
  20.  * express or implied warranty.
  21.  */
  22.  
  23. #ifndef lint
  24. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.12 91/10/27 16:17:07 ouster Exp $ SPRITE (Berkeley)";
  25. #endif
  26.  
  27. #include "tclInt.h"
  28.  
  29. /*
  30.  * Structure used to hold information about variable traces:
  31.  */
  32.  
  33. typedef struct {
  34.     int flags;            /* Operations for which Tcl command is
  35.                  * to be invoked. */
  36.     int length;            /* Number of non-NULL chars. in command. */
  37.     char command[4];        /* Space for Tcl command to invoke.  Actual
  38.                  * size will be as large as necessary to
  39.                  * hold command.  This field must be the
  40.                  * last in the structure, so that it can
  41.                  * be larger than 4 bytes. */
  42. } TraceVarInfo;
  43.  
  44. /*
  45.  * Forward declarations for procedures defined in this file:
  46.  */
  47.  
  48. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  49.                 Tcl_Interp *interp, char *name1, char *name2,
  50.                 int flags));
  51.  
  52. /*
  53.  *----------------------------------------------------------------------
  54.  *
  55.  * Tcl_RegexpCmd --
  56.  *
  57.  *    This procedure is invoked to process the "regexp" Tcl command.
  58.  *    See the user documentation for details on what it does.
  59.  *
  60.  * Results:
  61.  *    A standard Tcl result.
  62.  *
  63.  * Side effects:
  64.  *    See the user documentation.
  65.  *
  66.  *----------------------------------------------------------------------
  67.  */
  68.  
  69.     /* ARGSUSED */
  70. int
  71. Tcl_RegexpCmd(dummy, interp, argc, argv)
  72.     ClientData dummy;            /* Not used. */
  73.     Tcl_Interp *interp;            /* Current interpreter. */
  74.     int argc;                /* Number of arguments. */
  75.     char **argv;            /* Argument strings. */
  76. {
  77.     int noCase = 0;
  78.     int indices = 0;
  79.     regexp *regexpPtr;
  80.     char **argPtr, *string;
  81.     int match, i;
  82.  
  83.     if (argc < 3) {
  84.     wrongNumArgs:
  85.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  86.         " ?-nocase? exp string ?matchVar? ?subMatchVar ",
  87.         "subMatchVar ...?\"", (char *) NULL);
  88.     return TCL_ERROR;
  89.     }
  90.     argPtr = argv+1;
  91.     argc--;
  92.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  93.     if (strcmp(argPtr[0], "-indices") == 0) {
  94.         argPtr++;
  95.         argc--;
  96.         indices = 1;
  97.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  98.         argPtr++;
  99.         argc--;
  100.         noCase = 1;
  101.     } else {
  102.         break;
  103.     }
  104.     }
  105.     if (argc < 2) {
  106.     goto wrongNumArgs;
  107.     }
  108.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  109.     if (regexpPtr == NULL) {
  110.     return TCL_ERROR;
  111.     }
  112.  
  113.     /*
  114.      * Convert the string to lower case, if desired, and perform
  115.      * the match.
  116.      */
  117.  
  118.     if (noCase) {
  119.     register char *dst, *src;
  120.  
  121.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  122.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  123.         if (isupper(*src)) {
  124.         *dst = tolower(*src);
  125.         } else {
  126.         *dst = *src;
  127.         }
  128.     }
  129.     *dst = 0;
  130.     } else {
  131.     string = argPtr[1];
  132.     }
  133.     tclRegexpError = NULL;
  134.     match = regexec(regexpPtr, string);
  135.     if (string != argPtr[1]) {
  136.     ckfree(string);
  137.     }
  138.     if (tclRegexpError != NULL) {
  139.     Tcl_AppendResult(interp, "error while matching pattern: ",
  140.         tclRegexpError, (char *) NULL);
  141.     return TCL_ERROR;
  142.     }
  143.     if (!match) {
  144.     interp->result = "0";
  145.     return TCL_OK;
  146.     }
  147.  
  148.     /*
  149.      * If additional variable names have been specified, return
  150.      * index information in those variables.
  151.      */
  152.  
  153.     argc -= 2;
  154.     if (argc > NSUBEXP) {
  155.     interp->result = "too many substring variables";
  156.     return TCL_ERROR;
  157.     }
  158.     for (i = 0; i < argc; i++) {
  159.     char *result, info[50];
  160.  
  161.     if (regexpPtr->startp[i] == NULL) {
  162.         if (indices) {
  163.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  164.         } else {
  165.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  166.         }
  167.     } else {
  168.         if (indices) {
  169.         sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  170.             regexpPtr->endp[i] - string - 1);
  171.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  172.         } else {
  173.         char savedChar, *first, *last;
  174.  
  175.         first = argPtr[1] + (regexpPtr->startp[i] - string);
  176.         last = argPtr[1] + (regexpPtr->endp[i] - string);
  177.         savedChar = *last;
  178.         *last = 0;
  179.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  180.         *last = savedChar;
  181.         }
  182.     }
  183.     if (result == NULL) {
  184.         Tcl_AppendResult(interp, "couldn't set variable \"",
  185.             argPtr[i+2], "\"", (char *) NULL);
  186.         return TCL_ERROR;
  187.     }
  188.     }
  189.     interp->result = "1";
  190.     return TCL_OK;
  191. }
  192.  
  193. /*
  194.  *----------------------------------------------------------------------
  195.  *
  196.  * Tcl_RegsubCmd --
  197.  *
  198.  *    This procedure is invoked to process the "regsub" Tcl command.
  199.  *    See the user documentation for details on what it does.
  200.  *
  201.  * Results:
  202.  *    A standard Tcl result.
  203.  *
  204.  * Side effects:
  205.  *    See the user documentation.
  206.  *
  207.  *----------------------------------------------------------------------
  208.  */
  209.  
  210.     /* ARGSUSED */
  211. int
  212. Tcl_RegsubCmd(dummy, interp, argc, argv)
  213.     ClientData dummy;            /* Not used. */
  214.     Tcl_Interp *interp;            /* Current interpreter. */
  215.     int argc;                /* Number of arguments. */
  216.     char **argv;            /* Argument strings. */
  217. {
  218.     int noCase = 0, all = 0;
  219.     regexp *regexpPtr;
  220.     char *string, *p, *firstChar, *newValue, **argPtr;
  221.     int match, result, flags;
  222.     register char *src, c;
  223.  
  224.     if (argc < 5) {
  225.     wrongNumArgs:
  226.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  227.         " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
  228.     return TCL_ERROR;
  229.     }
  230.     argPtr = argv+1;
  231.     argc--;
  232.     while (argPtr[0][0] == '-') {
  233.     if (strcmp(argPtr[0], "-nocase") == 0) {
  234.         argPtr++;
  235.         argc--;
  236.         noCase = 1;
  237.     } else if (strcmp(argPtr[0], "-all") == 0) {
  238.         argPtr++;
  239.         argc--;
  240.         all = 1;
  241.     } else {
  242.         break;
  243.     }
  244.     }
  245.     if (argc != 4) {
  246.     goto wrongNumArgs;
  247.     }
  248.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  249.     if (regexpPtr == NULL) {
  250.     return TCL_ERROR;
  251.     }
  252.  
  253.     /*
  254.      * Convert the string to lower case, if desired.
  255.      */
  256.  
  257.     if (noCase) {
  258.     register char *dst;
  259.  
  260.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  261.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  262.         if (isupper(*src)) {
  263.         *dst = tolower(*src);
  264.         } else {
  265.         *dst = *src;
  266.         }
  267.     }
  268.     *dst = 0;
  269.     } else {
  270.     string = argPtr[1];
  271.     }
  272.  
  273.     /*
  274.      * The following loop is to handle multiple matches within the
  275.      * same source string;  each iteration handles one match and its
  276.      * corresponding substitution.  If "-all" hasn't been specified
  277.      * then the loop body only gets executed once.
  278.      */
  279.  
  280.     flags = 0;
  281.     for (p = string; *p != 0; ) {
  282.     tclRegexpError = NULL;
  283.     match = regexec(regexpPtr, p);
  284.     if (tclRegexpError != NULL) {
  285.         Tcl_AppendResult(interp, "error while matching pattern: ",
  286.             tclRegexpError, (char *) NULL);
  287.         result = TCL_ERROR;
  288.         goto done;
  289.     }
  290.     if (!match) {
  291.         break;
  292.     }
  293.  
  294.     /*
  295.      * Copy the portion of the source string before the match to the
  296.      * result variable.
  297.      */
  298.     
  299.     src = argPtr[1] + (regexpPtr->startp[0] - string);
  300.     c = *src;
  301.     *src = 0;
  302.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  303.         flags);
  304.     *src = c;
  305.     flags = TCL_APPEND_VALUE;
  306.     if (newValue == NULL) {
  307.         cantSet:
  308.         Tcl_AppendResult(interp, "couldn't set variable \"",
  309.             argPtr[3], "\"", (char *) NULL);
  310.         result = TCL_ERROR;
  311.         goto done;
  312.     }
  313.     
  314.     /*
  315.      * Append the subSpec argument to the variable, making appropriate
  316.      * substitutions.  This code is a bit hairy because of the backslash
  317.      * conventions and because the code saves up ranges of characters in
  318.      * subSpec to reduce the number of calls to Tcl_SetVar.
  319.      */
  320.     
  321.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  322.         int index;
  323.     
  324.         if (c == '&') {
  325.         index = 0;
  326.         } else if (c == '\\') {
  327.         c = src[1];
  328.         if ((c >= '0') && (c <= '9')) {
  329.             index = c - '0';
  330.         } else if ((c == '\\') || (c == '&')) {
  331.             *src = c;
  332.             src[1] = 0;
  333.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  334.                 TCL_APPEND_VALUE);
  335.             *src = '\\';
  336.             src[1] = c;
  337.             if (newValue == NULL) {
  338.             goto cantSet;
  339.             }
  340.             firstChar = src+2;
  341.             src++;
  342.             continue;
  343.         } else {
  344.             continue;
  345.         }
  346.         } else {
  347.         continue;
  348.         }
  349.         if (firstChar != src) {
  350.         c = *src;
  351.         *src = 0;
  352.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  353.             TCL_APPEND_VALUE);
  354.         *src = c;
  355.         if (newValue == NULL) {
  356.             goto cantSet;
  357.         }
  358.         }
  359.         if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  360.             && (regexpPtr->endp[index] != NULL)) {
  361.         char *first, *last, saved;
  362.     
  363.         first = argPtr[1] + (regexpPtr->startp[index] - string);
  364.         last = argPtr[1] + (regexpPtr->endp[index] - string);
  365.         saved = *last;
  366.         *last = 0;
  367.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  368.             TCL_APPEND_VALUE);
  369.         *last = saved;
  370.         if (newValue == NULL) {
  371.             goto cantSet;
  372.         }
  373.         }
  374.         if (*src == '\\') {
  375.         src++;
  376.         }
  377.         firstChar = src+1;
  378.     }
  379.     if (firstChar != src) {
  380.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  381.             TCL_APPEND_VALUE) == NULL) {
  382.         goto cantSet;
  383.         }
  384.     }
  385.     p = regexpPtr->endp[0];
  386.     if (!all) {
  387.         break;
  388.     }
  389.     }
  390.  
  391.     /*
  392.      * If there were no matches at all, then return a "0" result.
  393.      */
  394.  
  395.     if (p == string) {
  396.     interp->result = "0";
  397.     result = TCL_OK;
  398.     goto done;
  399.     }
  400.  
  401.     /*
  402.      * Copy the portion of the source string after the last match to the
  403.      * result variable.
  404.      */
  405.  
  406.     if (*p != 0) {
  407.     if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
  408.         goto cantSet;
  409.     }
  410.     }
  411.     interp->result = "1";
  412.     result = TCL_OK;
  413.  
  414.     done:
  415.     if (string != argPtr[1]) {
  416.     ckfree(string);
  417.     }
  418.     return result;
  419. }
  420.  
  421. /*
  422.  *----------------------------------------------------------------------
  423.  *
  424.  * Tcl_RenameCmd --
  425.  *
  426.  *    This procedure is invoked to process the "rename" Tcl command.
  427.  *    See the user documentation for details on what it does.
  428.  *
  429.  * Results:
  430.  *    A standard Tcl result.
  431.  *
  432.  * Side effects:
  433.  *    See the user documentation.
  434.  *
  435.  *----------------------------------------------------------------------
  436.  */
  437.  
  438.     /* ARGSUSED */
  439. int
  440. Tcl_RenameCmd(dummy, interp, argc, argv)
  441.     ClientData dummy;            /* Not used. */
  442.     Tcl_Interp *interp;            /* Current interpreter. */
  443.     int argc;                /* Number of arguments. */
  444.     char **argv;            /* Argument strings. */
  445. {
  446.     register Command *cmdPtr;
  447.     Interp *iPtr = (Interp *) interp;
  448.     Tcl_HashEntry *hPtr;
  449.     int _new;
  450.  
  451.     if (argc != 3) {
  452.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  453.         " oldName newName\"", (char *) NULL);
  454.     return TCL_ERROR;
  455.     }
  456.     if (argv[2][0] == '\0') {
  457.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  458.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  459.             "\": command doesn't exist", (char *) NULL);
  460.         return TCL_ERROR;
  461.     }
  462.     return TCL_OK;
  463.     }
  464.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  465.     if (hPtr != NULL) {
  466.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  467.         "\": command already exists", (char *) NULL);
  468.     return TCL_ERROR;
  469.     }
  470.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  471.     if (hPtr == NULL) {
  472.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  473.         "\":  command doesn't exist", (char *) NULL);
  474.     return TCL_ERROR;
  475.     }
  476.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  477.     Tcl_DeleteHashEntry(hPtr);
  478.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &_new);
  479.     Tcl_SetHashValue(hPtr, cmdPtr);
  480.     return TCL_OK;
  481. }
  482.  
  483. /*
  484.  *----------------------------------------------------------------------
  485.  *
  486.  * Tcl_ReturnCmd --
  487.  *
  488.  *    This procedure is invoked to process the "return" Tcl command.
  489.  *    See the user documentation for details on what it does.
  490.  *
  491.  * Results:
  492.  *    A standard Tcl result.
  493.  *
  494.  * Side effects:
  495.  *    See the user documentation.
  496.  *
  497.  *----------------------------------------------------------------------
  498.  */
  499.  
  500.     /* ARGSUSED */
  501. int
  502. Tcl_ReturnCmd(dummy, interp, argc, argv)
  503.     ClientData dummy;            /* Not used. */
  504.     Tcl_Interp *interp;            /* Current interpreter. */
  505.     int argc;                /* Number of arguments. */
  506.     char **argv;            /* Argument strings. */
  507. {
  508.     if (argc > 2) {
  509.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  510.         " ?value?\"", (char *) NULL);
  511.     return TCL_ERROR;
  512.     }
  513.     if (argc == 2) {
  514.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  515.     }
  516.     return TCL_RETURN;
  517. }
  518.  
  519. /*
  520.  *----------------------------------------------------------------------
  521.  *
  522.  * Tcl_ScanCmd --
  523.  *
  524.  *    This procedure is invoked to process the "scan" Tcl command.
  525.  *    See the user documentation for details on what it does.
  526.  *
  527.  * Results:
  528.  *    A standard Tcl result.
  529.  *
  530.  * Side effects:
  531.  *    See the user documentation.
  532.  *
  533.  *----------------------------------------------------------------------
  534.  */
  535.  
  536.     /* ARGSUSED */
  537. int
  538. Tcl_ScanCmd(dummy, interp, argc, argv)
  539.     ClientData dummy;            /* Not used. */
  540.     Tcl_Interp *interp;            /* Current interpreter. */
  541.     int argc;                /* Number of arguments. */
  542.     char **argv;            /* Argument strings. */
  543. {
  544.     int arg1Length;            /* Number of bytes in argument to be
  545.                      * scanned.  This gives an upper limit
  546.                      * on string field sizes. */
  547. #   define MAX_FIELDS 20
  548.     typedef struct {
  549.     char fmt;            /* Format for field. */
  550.     int size;            /* How many bytes to allow for
  551.                      * field. */
  552.     char *location;            /* Where field will be stored. */
  553.     } Field;
  554.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  555.                      * format string. */
  556.     register Field *curField;
  557.     int numFields = 0;            /* Number of fields actually
  558.                      * specified. */
  559.     int suppress;            /* Current field is assignment-
  560.                      * suppressed. */
  561.     int totalSize = 0;            /* Number of bytes needed to store
  562.                      * all results combined. */
  563.     char *results;            /* Where scanned output goes.  */
  564.     int numScanned;            /* sscanf's result. */
  565.     register char *fmt;
  566.     int i, widthSpecified;
  567.  
  568.     if (argc < 3) {
  569.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  570.         " string format ?varName varName ...?\"", (char *) NULL);
  571.     return TCL_ERROR;
  572.     }
  573.  
  574.     /*
  575.      * This procedure operates in four stages:
  576.      * 1. Scan the format string, collecting information about each field.
  577.      * 2. Allocate an array to hold all of the scanned fields.
  578.      * 3. Call sscanf to do all the dirty work, and have it store the
  579.      *    parsed fields in the array.
  580.      * 4. Pick off the fields from the array and assign them to variables.
  581.      */
  582.  
  583.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  584.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  585.     if (*fmt != '%') {
  586.         continue;
  587.     }
  588.     fmt++;
  589.     if (*fmt == '*') {
  590.         suppress = 1;
  591.         fmt++;
  592.     } else {
  593.         suppress = 0;
  594.     }
  595.     widthSpecified = 0;
  596.     while (isdigit(*fmt)) {
  597.         widthSpecified = 1;
  598.         fmt++;
  599.     }
  600.     if (suppress) {
  601.         continue;
  602.     }
  603.     if (numFields == MAX_FIELDS) {
  604.         interp->result = "too many fields to scan";
  605.         return TCL_ERROR;
  606.     }
  607.     curField = &fields[numFields];
  608.     numFields++;
  609.     switch (*fmt) {
  610.         case 'D':
  611.         case 'O':
  612.         case 'X':
  613.         case 'd':
  614.         case 'o':
  615.         case 'x':
  616.         curField->fmt = 'd';
  617.         curField->size = sizeof(int);
  618.         break;
  619.  
  620.         case 's':
  621.         curField->fmt = 's';
  622.         curField->size = arg1Length;
  623.         break;
  624.  
  625.         case 'c':
  626.                 if (widthSpecified) {
  627.                     interp->result = 
  628.                          "field width may not be specified in %c conversion";
  629.                     return TCL_ERROR;
  630.                 }
  631.         curField->fmt = 'c';
  632.         curField->size = sizeof(int);
  633.         break;
  634.  
  635.         case 'E':
  636.         case 'F':
  637.         curField->fmt = 'F';
  638.         curField->size = sizeof(double);
  639.         break;
  640.  
  641.         case 'e':
  642.         case 'f':
  643.         curField->fmt = 'f';
  644.         curField->size = sizeof(float);
  645.         break;
  646.  
  647.         case '[':
  648.         curField->fmt = 's';
  649.         curField->size = arg1Length;
  650.         do {
  651.             fmt++;
  652.         } while (*fmt != ']');
  653.         break;
  654.  
  655.         default:
  656.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  657.             *fmt);
  658.         return TCL_ERROR;
  659.     }
  660.     totalSize += curField->size;
  661.     }
  662.  
  663.     if (numFields != (argc-3)) {
  664.     interp->result =
  665.         "different numbers of variable names and field specifiers";
  666.     return TCL_ERROR;
  667.     }
  668.  
  669.     /*
  670.      * Step 2:
  671.      */
  672.  
  673.     results = (char *) ckalloc((unsigned) totalSize);
  674.     for (i = 0, totalSize = 0, curField = fields;
  675.         i < numFields; i++, curField++) {
  676.     curField->location = results + totalSize;
  677.     totalSize += curField->size;
  678.     }
  679.  
  680.     /*
  681.      * Step 3:
  682.      */
  683.  
  684.     numScanned = sscanf(argv[1], argv[2],
  685.         fields[0].location, fields[1].location, fields[2].location,
  686.         fields[3].location, fields[4].location, fields[5].location,
  687.         fields[6].location, fields[7].location, fields[8].location,
  688.         fields[9].location, fields[10].location, fields[11].location,
  689.         fields[12].location, fields[13].location, fields[14].location,
  690.         fields[15].location, fields[16].location, fields[17].location,
  691.         fields[18].location, fields[19].location);
  692.  
  693.     /*
  694.      * Step 4:
  695.      */
  696.  
  697.     if (numScanned < numFields) {
  698.     numFields = numScanned;
  699.     }
  700.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  701.     switch (curField->fmt) {
  702.         char string[120];
  703.  
  704.         case 'd':
  705.         sprintf(string, "%d", *((int *) curField->location));
  706.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  707.             storeError:
  708.             Tcl_AppendResult(interp,
  709.                 "couldn't set variable \"", argv[i+3], "\"",
  710.                 (char *) NULL);
  711.             ckfree((char *) results);
  712.             return TCL_ERROR;
  713.         }
  714.         break;
  715.  
  716.         case 'c':
  717.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  718.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  719.             goto storeError;
  720.         }
  721.         break;
  722.  
  723.         case 's':
  724.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  725.             == NULL) {
  726.             goto storeError;
  727.         }
  728.         break;
  729.  
  730.         case 'F':
  731.         sprintf(string, "%g", *((double *) curField->location));
  732.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  733.             goto storeError;
  734.         }
  735.         break;
  736.  
  737.         case 'f':
  738.         sprintf(string, "%g", *((float *) curField->location));
  739.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  740.             goto storeError;
  741.         }
  742.         break;
  743.     }
  744.     }
  745.     ckfree(results);
  746.     sprintf(interp->result, "%d", numScanned);
  747.     return TCL_OK;
  748. }
  749.  
  750. /*
  751.  *----------------------------------------------------------------------
  752.  *
  753.  * Tcl_SplitCmd --
  754.  *
  755.  *    This procedure is invoked to process the "split" Tcl command.
  756.  *    See the user documentation for details on what it does.
  757.  *
  758.  * Results:
  759.  *    A standard Tcl result.
  760.  *
  761.  * Side effects:
  762.  *    See the user documentation.
  763.  *
  764.  *----------------------------------------------------------------------
  765.  */
  766.  
  767.     /* ARGSUSED */
  768. int
  769. Tcl_SplitCmd(dummy, interp, argc, argv)
  770.     ClientData dummy;            /* Not used. */
  771.     Tcl_Interp *interp;            /* Current interpreter. */
  772.     int argc;                /* Number of arguments. */
  773.     char **argv;            /* Argument strings. */
  774. {
  775.     char *splitChars;
  776.     register char *p, *p2;
  777.     char *elementStart;
  778.  
  779.     if (argc == 2) {
  780.     splitChars = " \n\t\r";
  781.     } else if (argc == 3) {
  782.     splitChars = argv[2];
  783.     } else {
  784.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  785.         " string ?splitChars?\"", (char *) NULL);
  786.     return TCL_ERROR;
  787.     }
  788.  
  789.     /*
  790.      * Handle the special case of splitting on every character.
  791.      */
  792.  
  793.     if (*splitChars == 0) {
  794.     char string[2];
  795.     string[1] = 0;
  796.     for (p = argv[1]; *p != 0; p++) {
  797.         string[0] = *p;
  798.         Tcl_AppendElement(interp, string, 0);
  799.     }
  800.     return TCL_OK;
  801.     }
  802.  
  803.     /*
  804.      * Normal case: split on any of a given set of characters.
  805.      * Discard instances of the split characters.
  806.      */
  807.  
  808.     for (p = elementStart = argv[1]; *p != 0; p++) {
  809.     char c = *p;
  810.     for (p2 = splitChars; *p2 != 0; p2++) {
  811.         if (*p2 == c) {
  812.         *p = 0;
  813.         Tcl_AppendElement(interp, elementStart, 0);
  814.         *p = c;
  815.         elementStart = p+1;
  816.         break;
  817.         }
  818.     }
  819.     }
  820.     if (p != argv[1]) {
  821.     Tcl_AppendElement(interp, elementStart, 0);
  822.     }
  823.     return TCL_OK;
  824. }
  825.  
  826. /*
  827.  *----------------------------------------------------------------------
  828.  *
  829.  * Tcl_StringCmd --
  830.  *
  831.  *    This procedure is invoked to process the "string" Tcl command.
  832.  *    See the user documentation for details on what it does.
  833.  *
  834.  * Results:
  835.  *    A standard Tcl result.
  836.  *
  837.  * Side effects:
  838.  *    See the user documentation.
  839.  *
  840.  *----------------------------------------------------------------------
  841.  */
  842.  
  843.     /* ARGSUSED */
  844. int
  845. Tcl_StringCmd(dummy, interp, argc, argv)
  846.     ClientData dummy;            /* Not used. */
  847.     Tcl_Interp *interp;            /* Current interpreter. */
  848.     int argc;                /* Number of arguments. */
  849.     char **argv;            /* Argument strings. */
  850. {
  851.     int length;
  852.     register char *p, c;
  853.     int match;
  854.     int first;
  855.     int left = 0, right = 0;
  856.  
  857.     if (argc < 2) {
  858.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  859.         " option arg ?arg ...?\"", (char *) NULL);
  860.     return TCL_ERROR;
  861.     }
  862.     c = argv[1][0];
  863.     length = strlen(argv[1]);
  864.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  865.     if (argc != 4) {
  866.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  867.             " compare string1 string2\"", (char *) NULL);
  868.         return TCL_ERROR;
  869.     }
  870.     match = strcmp(argv[2], argv[3]);
  871.     if (match > 0) {
  872.         interp->result = "1";
  873.     } else if (match < 0) {
  874.         interp->result = "-1";
  875.     } else {
  876.         interp->result = "0";
  877.     }
  878.     return TCL_OK;
  879.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  880.     if (argc != 4) {
  881.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  882.             " first string1 string2\"", (char *) NULL);
  883.         return TCL_ERROR;
  884.     }
  885.     first = 1;
  886.  
  887.     firstLast:
  888.     match = -1;
  889.     c = *argv[2];
  890.     length = strlen(argv[2]);
  891.     for (p = argv[3]; *p != 0; p++) {
  892.         if (*p != c) {
  893.         continue;
  894.         }
  895.         if (strncmp(argv[2], p, length) == 0) {
  896.         match = p-argv[3];
  897.         if (first) {
  898.             break;
  899.         }
  900.         }
  901.     }
  902.     sprintf(interp->result, "%d", match);
  903.     return TCL_OK;
  904.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  905.     int index;
  906.  
  907.     if (argc != 4) {
  908.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  909.             " index string charIndex\"", (char *) NULL);
  910.         return TCL_ERROR;
  911.     }
  912.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  913.         return TCL_ERROR;
  914.     }
  915.     if ((index >= 0) && (index < strlen(argv[2]))) {
  916.         interp->result[0] = argv[2][index];
  917.         interp->result[1] = 0;
  918.     }
  919.     return TCL_OK;
  920.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  921.         && (length >= 2)) {
  922.     if (argc != 4) {
  923.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  924.             " last string1 string2\"", (char *) NULL);
  925.         return TCL_ERROR;
  926.     }
  927.     first = 0;
  928.     goto firstLast;
  929.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  930.         && (length >= 2)) {
  931.     if (argc != 3) {
  932.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  933.             " length string\"", (char *) NULL);
  934.         return TCL_ERROR;
  935.     }
  936.     sprintf(interp->result, "%d", strlen(argv[2]));
  937.     return TCL_OK;
  938.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  939.     if (argc != 4) {
  940.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  941.             " match pattern string\"", (char *) NULL);
  942.         return TCL_ERROR;
  943.     }
  944.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  945.         interp->result = "1";
  946.     } else {
  947.         interp->result = "0";
  948.     }
  949.     return TCL_OK;
  950.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  951.     int first, last, stringLength;
  952.  
  953.     if (argc != 5) {
  954.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  955.             " range string first last\"", (char *) NULL);
  956.         return TCL_ERROR;
  957.     }
  958.     stringLength = strlen(argv[2]);
  959.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  960.         return TCL_ERROR;
  961.     }
  962.     if ((*argv[4] == 'e')
  963.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  964.         last = stringLength-1;
  965.     } else {
  966.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  967.         Tcl_ResetResult(interp);
  968.         Tcl_AppendResult(interp,
  969.             "expected integer or \"end\" but got \"",
  970.             argv[4], "\"", (char *) NULL);
  971.         return TCL_ERROR;
  972.         }
  973.     }
  974.     if (first < 0) {
  975.         first = 0;
  976.     }
  977.     if (last >= stringLength) {
  978.         last = stringLength-1;
  979.     }
  980.     if (last >= first) {
  981.         char saved, *p;
  982.  
  983.         p = argv[2] + last + 1;
  984.         saved = *p;
  985.         *p = 0;
  986.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  987.         *p = saved;
  988.     }
  989.     return TCL_OK;
  990.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  991.         && (length >= 3)) {
  992.     register char *p;
  993.  
  994.     if (argc != 3) {
  995.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  996.             " tolower string\"", (char *) NULL);
  997.         return TCL_ERROR;
  998.     }
  999.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1000.     for (p = interp->result; *p != 0; p++) {
  1001.         if (isupper(*p)) {
  1002.         *p = tolower(*p);
  1003.         }
  1004.     }
  1005.     return TCL_OK;
  1006.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1007.         && (length >= 3)) {
  1008.     register char *p;
  1009.  
  1010.     if (argc != 3) {
  1011.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1012.             " toupper string\"", (char *) NULL);
  1013.         return TCL_ERROR;
  1014.     }
  1015.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1016.     for (p = interp->result; *p != 0; p++) {
  1017.         if (islower(*p)) {
  1018.         *p = toupper(*p);
  1019.         }
  1020.     }
  1021.     return TCL_OK;
  1022.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1023.         && (length == 4)) {
  1024.     char *trimChars;
  1025.     register char *p, *checkPtr;
  1026.  
  1027.     left = right = 1;
  1028.  
  1029.     trim:
  1030.     if (argc == 4) {
  1031.         trimChars = argv[3];
  1032.     } else if (argc == 3) {
  1033.         trimChars = " \t\n\r";
  1034.     } else {
  1035.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1036.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1037.         return TCL_ERROR;
  1038.     }
  1039.     p = argv[2];
  1040.     if (left) {
  1041.         for (c = *p; c != 0; p++, c = *p) {
  1042.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1043.             if (*checkPtr == 0) {
  1044.             goto doneLeft;
  1045.             }
  1046.         }
  1047.         }
  1048.     }
  1049.     doneLeft:
  1050.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1051.     if (right) {
  1052.         char *donePtr;
  1053.  
  1054.         p = interp->result + strlen(interp->result) - 1;
  1055.         donePtr = &interp->result[-1];
  1056.         for (c = *p; p != donePtr; p--, c = *p) {
  1057.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1058.             if (*checkPtr == 0) {
  1059.             goto doneRight;
  1060.             }
  1061.         }
  1062.         }
  1063.         doneRight:
  1064.         p[1] = 0;
  1065.     }
  1066.     return TCL_OK;
  1067.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1068.         && (length > 4)) {
  1069.     left = 1;
  1070.     argv[1] = "trimleft";
  1071.     goto trim;
  1072.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1073.         && (length > 4)) {
  1074.     right = 1;
  1075.     argv[1] = "trimright";
  1076.     goto trim;
  1077.     } else {
  1078.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1079.         "\": should be compare, first, index, last, length, match, ",
  1080.         "range, tolower, toupper, trim, trimleft, or trimright",
  1081.         (char *) NULL);
  1082.     return TCL_ERROR;
  1083.     }
  1084. }
  1085.  
  1086. /*
  1087.  *----------------------------------------------------------------------
  1088.  *
  1089.  * Tcl_TraceCmd --
  1090.  *
  1091.  *    This procedure is invoked to process the "trace" Tcl command.
  1092.  *    See the user documentation for details on what it does.
  1093.  *
  1094.  * Results:
  1095.  *    A standard Tcl result.
  1096.  *
  1097.  * Side effects:
  1098.  *    See the user documentation.
  1099.  *
  1100.  *----------------------------------------------------------------------
  1101.  */
  1102.  
  1103.     /* ARGSUSED */
  1104. int
  1105. Tcl_TraceCmd(dummy, interp, argc, argv)
  1106.     ClientData dummy;            /* Not used. */
  1107.     Tcl_Interp *interp;            /* Current interpreter. */
  1108.     int argc;                /* Number of arguments. */
  1109.     char **argv;            /* Argument strings. */
  1110. {
  1111.     char c;
  1112.     int length;
  1113.  
  1114.     if (argc < 2) {
  1115.     Tcl_AppendResult(interp, "too few args: should be \"",
  1116.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1117.     return TCL_ERROR;
  1118.     }
  1119.     c = argv[1][1];
  1120.     length = strlen(argv[1]);
  1121.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1122.         && (length >= 2)) {
  1123.     char *p;
  1124.     int flags, length;
  1125.     TraceVarInfo *tvarPtr;
  1126.  
  1127.     if (argc != 5) {
  1128.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1129.             argv[0], " variable name ops command\"", (char *) NULL);
  1130.         return TCL_ERROR;
  1131.     }
  1132.  
  1133.     flags = 0;
  1134.     for (p = argv[3] ; *p != 0; p++) {
  1135.         if (*p == 'r') {
  1136.         flags |= TCL_TRACE_READS;
  1137.         } else if (*p == 'w') {
  1138.         flags |= TCL_TRACE_WRITES;
  1139.         } else if (*p == 'u') {
  1140.         flags |= TCL_TRACE_UNSETS;
  1141.         } else {
  1142.         goto badOps;
  1143.         }
  1144.     }
  1145.     if (flags == 0) {
  1146.         goto badOps;
  1147.     }
  1148.  
  1149.     length = strlen(argv[4]);
  1150.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1151.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1152.     tvarPtr->flags = flags;
  1153.     tvarPtr->length = length;
  1154.     flags |= TCL_TRACE_UNSETS;
  1155.     strcpy(tvarPtr->command, argv[4]);
  1156.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1157.         (ClientData) tvarPtr) != TCL_OK) {
  1158.         ckfree((char *) tvarPtr);
  1159.         return TCL_ERROR;
  1160.     }
  1161.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1162.         && (length >= 2)) == 0) {
  1163.     char *p;
  1164.     int flags, length;
  1165.     TraceVarInfo *tvarPtr;
  1166.     ClientData clientData;
  1167.  
  1168.     if (argc != 5) {
  1169.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1170.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1171.         return TCL_ERROR;
  1172.     }
  1173.  
  1174.     flags = 0;
  1175.     for (p = argv[3] ; *p != 0; p++) {
  1176.         if (*p == 'r') {
  1177.         flags |= TCL_TRACE_READS;
  1178.         } else if (*p == 'w') {
  1179.         flags |= TCL_TRACE_WRITES;
  1180.         } else if (*p == 'u') {
  1181.         flags |= TCL_TRACE_UNSETS;
  1182.         } else {
  1183.         goto badOps;
  1184.         }
  1185.     }
  1186.     if (flags == 0) {
  1187.         goto badOps;
  1188.     }
  1189.  
  1190.     /*
  1191.      * Search through all of our traces on this variable to
  1192.      * see if there's one with the given command.  If so, then
  1193.      * delete the first one that matches.
  1194.      */
  1195.  
  1196.     length = strlen(argv[4]);
  1197.     clientData = 0;
  1198.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1199.         TraceVarProc, clientData)) != 0) {
  1200.         tvarPtr = (TraceVarInfo *) clientData;
  1201.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1202.             && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1203.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1204.             TraceVarProc, clientData);
  1205.         ckfree((char *) tvarPtr);
  1206.         break;
  1207.         }
  1208.     }
  1209.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1210.         && (length >= 2)) {
  1211.     ClientData clientData;
  1212.     char ops[4], *p;
  1213.     char *prefix = "{";
  1214.  
  1215.     if (argc != 3) {
  1216.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1217.             argv[0], " vinfo name\"", (char *) NULL);
  1218.         return TCL_ERROR;
  1219.     }
  1220.     clientData = 0;
  1221.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1222.         TraceVarProc, clientData)) != 0) {
  1223.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1224.         p = ops;
  1225.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1226.         *p = 'r';
  1227.         p++;
  1228.         }
  1229.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1230.         *p = 'w';
  1231.         p++;
  1232.         }
  1233.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1234.         *p = 'u';
  1235.         p++;
  1236.         }
  1237.         *p = '\0';
  1238.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1239.         Tcl_AppendElement(interp, ops, 1);
  1240.         Tcl_AppendElement(interp, tvarPtr->command, 0);
  1241.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1242.         tvarPtr->command[tvarPtr->length] = ' ';
  1243.         prefix = " {";
  1244.     }
  1245.     } else {
  1246.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1247.         "\": should be variable, vdelete, or vinfo",
  1248.         (char *) NULL);
  1249.     return TCL_ERROR;
  1250.     }
  1251.     return TCL_OK;
  1252.  
  1253.     badOps:
  1254.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1255.         "\": should be one or more of rwu", (char *) NULL);
  1256.     return TCL_ERROR;
  1257. }
  1258.  
  1259. /*
  1260.  *----------------------------------------------------------------------
  1261.  *
  1262.  * TraceVarProc --
  1263.  *
  1264.  *    This procedure is called to handle variable accesses that have
  1265.  *    been traced using the "trace" command.
  1266.  *
  1267.  * Results:
  1268.  *    Normally returns NULL.  If the trace command returns an error,
  1269.  *    then this procedure returns an error string.
  1270.  *
  1271.  * Side effects:
  1272.  *    Depends on the command associated with the trace.
  1273.  *
  1274.  *----------------------------------------------------------------------
  1275.  */
  1276.  
  1277.     /* ARGSUSED */
  1278. static char *
  1279. TraceVarProc(clientData, interp, name1, name2, flags)
  1280.     ClientData clientData;    /* Information about the variable trace. */
  1281.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1282.     char *name1;        /* Name of variable or array. */
  1283.     char *name2;        /* Name of element within array;  NULL means
  1284.                  * scalar variable is being referenced. */
  1285.     int flags;            /* OR-ed bits giving operation and other
  1286.                  * information. */
  1287. {
  1288.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1289.     char *result;
  1290.     int code, cmdLength, flags1, flags2;
  1291.     Interp dummy;
  1292. #define STATIC_SIZE 199
  1293.     char staticSpace[STATIC_SIZE+1];
  1294.     char *cmdPtr, *p;
  1295.  
  1296.     result = NULL;
  1297.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1298.  
  1299.     /*
  1300.      * Generate a command to execute by appending list elements
  1301.      * for the two variable names and the operation.  The five
  1302.      * extra characters are for three space, the opcode character,
  1303.      * and the terminating null.
  1304.      */
  1305.  
  1306.     if (name2 == NULL) {
  1307.         name2 = "";
  1308.     }
  1309.     cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
  1310.         Tcl_ScanElement(name2, &flags2) + 5;
  1311.     if (cmdLength < STATIC_SIZE) {
  1312.         cmdPtr = staticSpace;
  1313.     } else {
  1314.         cmdPtr = (char *) ckalloc((unsigned) cmdLength);
  1315.     }
  1316.     p = cmdPtr;
  1317.     strcpy(p, tvarPtr->command);
  1318.     p += tvarPtr->length;
  1319.     *p = ' ';
  1320.     p++;
  1321.     p += Tcl_ConvertElement(name1, p, flags1);
  1322.     *p = ' ';
  1323.     p++;
  1324.     p += Tcl_ConvertElement(name2, p, flags2);
  1325.     *p = ' ';
  1326.     if (flags & TCL_TRACE_READS) {
  1327.         p[1] = 'r';
  1328.     } else if (flags & TCL_TRACE_WRITES) {
  1329.         p[1] = 'w';
  1330.     } else if (flags & TCL_TRACE_UNSETS) {
  1331.         p[1] = 'u';
  1332.     }
  1333.     p[2] = '\0';
  1334.  
  1335.     /*
  1336.      * Execute the command.  Be careful to save and restore the
  1337.      * result from the interpreter used for the command.
  1338.      */
  1339.  
  1340.     dummy.freeProc = interp->freeProc;
  1341.     if (interp->freeProc == 0) {
  1342.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1343.     } else {
  1344.         dummy.result = interp->result;
  1345.     }
  1346.     code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
  1347.     if (cmdPtr != staticSpace) {
  1348.         ckfree(cmdPtr);
  1349.     }
  1350.     if (code != TCL_OK) {
  1351.         result = "access disallowed by trace command";
  1352.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1353.     }
  1354.     Tcl_FreeResult(interp);
  1355.     interp->result = dummy.result;
  1356.     interp->freeProc = dummy.freeProc;
  1357.     }
  1358.     if (flags & TCL_TRACE_DESTROYED) {
  1359.     ckfree((char *) tvarPtr);
  1360.     }
  1361.     return result;
  1362. }
  1363.  
  1364. /*
  1365.  *----------------------------------------------------------------------
  1366.  *
  1367.  * Tcl_WhileCmd --
  1368.  *
  1369.  *    This procedure is invoked to process the "while" Tcl command.
  1370.  *    See the user documentation for details on what it does.
  1371.  *
  1372.  * Results:
  1373.  *    A standard Tcl result.
  1374.  *
  1375.  * Side effects:
  1376.  *    See the user documentation.
  1377.  *
  1378.  *----------------------------------------------------------------------
  1379.  */
  1380.  
  1381.     /* ARGSUSED */
  1382. int
  1383. Tcl_WhileCmd(dummy, interp, argc, argv)
  1384.     ClientData dummy;            /* Not used. */
  1385.     Tcl_Interp *interp;            /* Current interpreter. */
  1386.     int argc;                /* Number of arguments. */
  1387.     char **argv;            /* Argument strings. */
  1388. {
  1389.     int result, value;
  1390.  
  1391.     if (argc != 3) {
  1392.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1393.         argv[0], " test command\"", (char *) NULL);
  1394.     return TCL_ERROR;
  1395.     }
  1396.  
  1397.     while (1) {
  1398.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1399.     if (result != TCL_OK) {
  1400.         return result;
  1401.     }
  1402.     if (!value) {
  1403.         break;
  1404.     }
  1405.     result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
  1406.     if (result == TCL_CONTINUE) {
  1407.         result = TCL_OK;
  1408.     } else if (result != TCL_OK) {
  1409.         if (result == TCL_ERROR) {
  1410.         char msg[60];
  1411.         sprintf(msg, "\n    (\"while\" body line %d)",
  1412.             interp->errorLine);
  1413.         Tcl_AddErrorInfo(interp, msg);
  1414.         }
  1415.         break;
  1416.     }
  1417.     }
  1418.     if (result == TCL_BREAK) {
  1419.     result = TCL_OK;
  1420.     }
  1421.     if (result == TCL_OK) {
  1422.     Tcl_ResetResult(interp);
  1423.     }
  1424.     return result;
  1425. }
  1426.